module Language.HtmlParsec.HtmlParsec where

import Language.HtmlParsec.Syntax
import Language.HtmlParsec.PosTagSoupParsec
import Text.ParserCombinators.Parsec 
import Text.HTML.TagSoup
import Data.List


parseTags' = parseTagsOptions parseOptions {optTagPosition = True}

-- die "gefundene" Funktion ;-)
parser :: String -> Html
parser s = getRight $ parse htmlParser "default" $ parseTags' s -- <--- hmmm durch 'getRight $ parse htmlParser "default"' ersetzt ...

-- | Returns the parsed Html-Data or displays an error message
getRight :: Either ParseError a -> a
getRight (Right x)  = x
getRight (Left err) = error ("parse error: " ++ show err)

-- | checks if an Element is not an UnknownTag and returns a Bool value
isKnownTag :: Element -> Bool
isKnownTag (UnknownTag _) = False
isKnownTag _          = True

-- | checks if a Field element is not an UnknownFieldType and returns a Bool value
isKnownFieldType :: Field -> Bool
isKnownFieldType (UnknownFieldType _) = False
isKnownFieldType _                = True

-- | checks if a TagText is not a newline
isNotNewline :: (Tag String) -> Bool
isNotNewline (TagText "\n") = False
isNotNewline _              = True

-- | parses a Tag that is not TagClose "html" and returns an UnknownTag Element
unknownTagParser :: TagParser Element
unknownTagParser = do
  { try (notCloseTag "html") <|> fail "fatal user error"
  ; p <- getPosition
  ; return $ UnknownTag (mkPos p)
  }

-- | parses a Tag that is not TagClose "p" and returns an UnknownTag Element
unknownTagInParagraphParser :: TagParser Element
unknownTagInParagraphParser = do
  { try (notCloseTag "p")
    <|> fail "fatal user error"
  ; p <- getPosition
  ; return $ UnknownTag (mkPos p)
  }

-- | Parses a Tag List and returns only known tags
htmlParser :: TagParser Html
htmlParser = do
  { openTag "html"
  ; p <- getPosition
  ; elems <- many ((try elementParser) <|> unknownTagParser)
  ; closeTag "html"
  ; return (Html (mkPos p) (filter isKnownTag elems))
  }

-- | parses an input Tag
fieldParser :: TagParser Field
fieldParser = do
  { many (try notOpenInputTag) -- alle Tags ignorieren die keine input-open-tags sind (gilt insbesondere fuer text und whitespace)
  ; tag <- openTag "input"
  ; p <- getPosition
  ; let fType = fromAttrib "type" tag
  ; let fName = fromAttrib "name" tag
  ; let fValue = fromAttrib "value" tag
  ; closeTag "input"
  ; many (try notOpenInputTag) -- damit auch nach dem letzten input-tag etwas anders als </form> stehen kann (gilt auch fuer newline)
  ; case fType of
      "text"   -> return (Textfield (mkPos p) fName fValue)
      "radio"  -> return (Radio (mkPos p) fName fValue)
      "submit" -> return (Submit (mkPos p) fName)
      "reset"  -> return (Reset (mkPos p) fName)
      _        -> return (UnknownFieldType (mkPos p))
  }

-- | parses a tag (which is not an input-open-tag) and returns it, or fails if a form-close-tag is parsed - very useful to ignore tags within a form-tag that should not be parsed
notOpenInputTag :: GenParser (Tag String) st (Tag String)
notOpenInputTag = do
  { tag <- notOpenTag "input"
  ; if (isTagCloseName "form" tag)
      then fail "end of form reached - this is not an error"
      else return tag
  }

-- | parses a form tag, yet only simple input-forms
formParser :: TagParser Element
formParser = do
  { tag <- openTag "form"
  ; p <- getPosition
  ; let action = fromAttrib "action" tag
  ; fields <- many fieldParser
  ; closeTag "form"
  ; return (Form (mkPos p) action (filter isKnownFieldType fields))
  }

-- | parses element tags, TagText is allways parsed to plain text
elementParser :: TagParser Element
elementParser = do
  { elem <- try varParser
        <|> try plainParser
        <|> try headingParser
        <|> try formParser
        <|> try paragraphParser
        <|> fail "elementParser error"
  ; return elem
  }

-- | parses plain text and ignores TagText "\n"
plainParser :: TagParser Element
plainParser = do
  { tag <- notOpenTag "x"
  ; p <- getPosition
  ; if ((isTagText tag) && (isNotNewline tag))
      then return (Plain (mkPos p) (fromTagText tag))
      else fail "fatal user error"
  }

varParser :: TagParser Element
varParser = do
  { tag <- notOpenTag "x"
  ; p <- getPosition
  ; if ((isTagText tag) && "$" `isPrefixOf` (fromTagText tag) && "$" `isSuffixOf` (fromTagText tag) && (isNotNewline tag))
      then return (Var (mkPos p) (tail $ init $ fromTagText tag))
      else fail "fatal user error"
  }



-- | parses headings from h1 up to h6
headingParser :: TagParser Element
headingParser = do
  { heading <- try (hParser 1)
           <|> try (hParser 2)
           <|> try (hParser 3)
           <|> try (hParser 4)
           <|> try (hParser 5)
           <|> try (hParser 6)
           <|> fail "headings above level 6 are not supported"
  ; return heading
  }

-- | parses a heading-tag with level n
hParser :: Int -> TagParser Element
hParser n = do
  { tag <- openTag ("h"++show n)
  ; p <- getPosition
  ; textTag <- notOpenTag "x"
  ; let text = if isTagText textTag
                 then (fromTagText textTag)
                 else ""
  ; if (isTagText textTag)
      then closeTag ("h"++show n)
      else error "empty headings are not supported"
  ; return (Heading (mkPos p) n text)
  }

-- | parses a paragraph-tag and ignores all unknown tags within
paragraphParser :: TagParser Element
paragraphParser = do
  { openTag "p"
  ; pos <- getPosition
  ; elems <- many ((try elementParser) <|> unknownTagInParagraphParser)
  ; closeTag "p"
  ; return (Paragraph (mkPos pos) (filter isKnownTag elems))
  }

mkPos :: SourcePos -> Position
mkPos pos = (P (sourceLine pos) (sourceColumn pos))

-- ein paar Tests

s1 = "<html>asdasd</html>"
s2 = "<h1>asdasd</html></h1>"
s3 = "<h1>asdasd</html></h2>" 

testhtml = parse htmlParser "default" $ parseTags' s1
testh1 = parse (hParser 1) "default" $ parseTags' s2
failedtesth1 = parse (hParser 1) "default" $ parseTags' s3

-- convenience

readtags :: String -> IO [(Tag String)]
readtags f = do
  s <- readFile f
  return $ parseTags s

showtags :: [(Tag String)] -> IO ()
showtags ts = mapM_ print ts
